home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / combin.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  14KB  |  344 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defun null-wrappers-method-function (&rest args)
  31.   ;; Function returned when get-method-function passed no wrappers for
  32.   ;; caching.  I'm not exactly sure why get-method-function gets called
  33.   ;; with null wrappers when a generic function is first created, but
  34.   ;; they do.  However, the method-function returned never seemed to
  35.   ;; get called, so to save a bunch of unneed closure-generation
  36.   ;; and other muckity-muck, this function is just returned instead.
  37.   (error "Internal PCL error:  Calling method-function created by
  38.           get-method-function with wrappers NIL.  Called with args: ~S"
  39.          args))
  40.  
  41. (defun get-method-function (method &optional method-alist wrappers)
  42.   (or (cadr (assq method method-alist))
  43.       (if wrappers
  44.       (method-function-for-caching method wrappers)
  45.       (or (method-optimized-function method)
  46.               #'null-wrappers-method-function))))
  47.  
  48. (defun make-effective-method-function (generic-function form &optional 
  49.                        method-alist wrappers)
  50.   (funcall-function (make-effective-method-function1 generic-function form)
  51.                 method-alist wrappers))
  52.  
  53. (defun make-effective-method-function1 (generic-function form)
  54.   (if (and (listp form)
  55.        (eq (car form) 'call-method)
  56.        (method-p (cadr form))
  57.        (or (every #'method-p (caddr form))
  58.            (not (method-needs-next-methods-p (cadr form)))))
  59.       (make-effective-method-function-simple generic-function form)
  60.       ;;
  61.       ;; We have some sort of `real' effective method.  Go off and get a
  62.       ;; compiled function for it.  Most of the real hair here is done by
  63.       ;; the GET-FUNCTION mechanism.
  64.       ;; 
  65.       (make-effective-method-function-internal generic-function form)))
  66.  
  67. (defun make-effective-method-function-simple (generic-function form)
  68.   ;;
  69.   ;; The effective method is just a call to call-method.  This opens up
  70.   ;; the possibility of just using the method function of the method as
  71.   ;; as the effective method function.
  72.   ;;
  73.   ;; But we have to be careful.  If that method function will ask for
  74.   ;; the next methods we have to provide them.  We do not look to see
  75.   ;; if there are next methods, we look at whether the method function
  76.   ;; asks about them.  If it does, we must tell it whether there are
  77.   ;; or aren't to prevent the leaky next methods bug.
  78.   ;; 
  79.   (let ((method (cadr form)))
  80.     (if (not (method-needs-next-methods-p method))
  81.     #'(lambda (method-alist wrappers)
  82.         (get-method-function method method-alist wrappers))
  83.     (let* ((arg-info (gf-arg-info generic-function))
  84.            (metatypes (arg-info-metatypes arg-info))
  85.            (applyp (arg-info-applyp arg-info))
  86.            (next-methods (caddr form)))
  87.       (declare (type boolean applyp))
  88.       (multiple-value-bind (cfunction constants)
  89.           (get-function1
  90.            `(lambda ,(make-dfun-lambda-list metatypes applyp)
  91.           (let ((*next-methods* .next-methods.))
  92.             ,(make-dfun-call metatypes applyp '.method.)))
  93.            #'default-test-converter ;This could be optimized by making
  94.                     ;the interface from here to the
  95.                     ;walker more clear so that the
  96.                     ;form wouldn't get walked at all.
  97.            #'(lambda (form)
  98.            (if (memq form '(.next-methods. .method.))
  99.                (values form (list form))
  100.                form))
  101.            #'(lambda (form)
  102.            (cond ((eq form '.next-methods.)
  103.               (list (cons '.meth-list. next-methods)))
  104.              ((eq form '.method.)
  105.               (list (cons '.meth. method))))))
  106.         #'(lambda (method-alist wrappers)
  107.         (flet ((fix-meth (meth)
  108.              (get-method-function meth method-alist wrappers)))
  109.           (apply-function cfunction
  110.                   (mapcar #'(lambda (constant)
  111.                           (cond ((atom constant)
  112.                              constant)
  113.                             ((eq (car constant) '.meth.)
  114.                              (fix-meth (cdr constant)))
  115.                             ((eq (car constant) '.meth-list.)
  116.                              (mapcar #'fix-meth (cdr constant)))
  117.                             (t constant)))
  118.                       constants)))))))))
  119.  
  120. (declaim (type list *global-effective-method-gensyms*))
  121. (defvar *global-effective-method-gensyms* ())
  122. (defvar *rebound-effective-method-gensyms*)
  123.  
  124. (defun get-effective-method-gensym ()
  125.   (or (pop *rebound-effective-method-gensyms*)
  126.       (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" 
  127.                  (length *global-effective-method-gensyms*))
  128.              "PCL")))
  129.     (setq *global-effective-method-gensyms*
  130.           (append *global-effective-method-gensyms* (list new)))
  131.     new)))
  132.  
  133. (let ((*rebound-effective-method-gensyms* ()))
  134.   (dotimes (i 10) (get-effective-method-gensym)))
  135.  
  136. (defun make-effective-method-function-internal (generic-function effective-method)
  137.   (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
  138.      (arg-info (gf-arg-info generic-function))
  139.      (metatypes (arg-info-metatypes arg-info))
  140.      (applyp (arg-info-applyp arg-info)))
  141.     (declare (type boolean applyp))
  142.     (labels ((test-converter (form)
  143.            (if (and (consp form) (eq (car form) 'call-method))
  144.            (if (caddr form)
  145.                '.call-method-with-next.
  146.                '.call-method-without-next.)
  147.            (default-test-converter form)))
  148.          (code-converter (form)
  149.            (if (and (consp form) (eq (car form) 'call-method))
  150.            ;;
  151.            ;; We have a `call' to CALL-METHOD.  There may or may not be next
  152.            ;; methods and the two cases are a little different.  It controls
  153.            ;; how many gensyms we will generate.
  154.            ;;
  155.            (let ((gensyms
  156.               (if (caddr form)
  157.                   (list (get-effective-method-gensym)
  158.                     (get-effective-method-gensym))
  159.                   (list (get-effective-method-gensym)))))
  160.              (values `(let ((*next-methods* ,(cadr gensyms)))
  161.                    ,(make-dfun-call metatypes applyp (car gensyms)))
  162.                  gensyms))
  163.            (default-code-converter form)))
  164.          (constant-converter (form)
  165.            (if (and (consp form) (eq (car form) 'call-method))
  166.            (if (caddr form)
  167.                (list (cons '.meth. (check-for-make-method (cadr form)))
  168.                  (cons '.meth-list.
  169.                    (mapcar #'check-for-make-method (caddr form))))
  170.                (list (cons '.meth. (check-for-make-method (cadr form)))))
  171.            (default-constant-converter form)))
  172.          (check-for-make-method (effective-method)
  173.            (cond ((method-p effective-method)
  174.               effective-method)
  175.              ((and (listp effective-method)
  176.                (eq (car effective-method) 'make-method))
  177.               (make-effective-method-function1
  178.                generic-function
  179.                (make-progn (cadr effective-method))))
  180.              (t
  181.               (error "Effective-method form is malformed.")))))
  182.       (multiple-value-bind (cfunction constants)
  183.       (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp)
  184.                ,effective-method)
  185.              #'test-converter
  186.              #'code-converter
  187.              #'constant-converter)
  188.     #'(lambda (method-alist wrappers)
  189.         (flet ((fix-meth (meth)
  190.              (if (method-p meth)
  191.              (get-method-function meth method-alist wrappers)
  192.              (funcall-function meth method-alist wrappers))))
  193.           (apply-function cfunction
  194.                   (mapcar #'(lambda (constant)
  195.